Programming Languages Suite/ProgramD2.iso/Borland/Borland Pascal with Objects 7.0/RWDEMOS.ZIP/BITBTN.PAS

Pascal/Delphi Source File | 1992-10-27 | 21.7 KB | 721 lines

{************************************************}
{                                                }
{   Resource Workshop Demo library               }
{   Copyright (c) 1992 by Borland International  }
{                                                }
{************************************************}

library BitBtn;

uses WinTypes, WinProcs, Strings, CustCntl, BitBtnCo;

{$R BITBTN.RES}

{ ==============================================================
  Bitmaped button custom control.
  ============================================================== }

const
  ofReserved    = 0;  { Used by the dialog manager }
  ofState       = 2;
  ofDownBits    = 4;
  ofUpBits      = 6;
  ofFocUpBits   = 8;
  ofSize        = 10; { Amount of window extra bytes to use }

const
  bdBorderWidth = 1;

const
  bsDisabled    = $0001;
  bsFocus       = $0002;
  bsKeyDown     = $0004;
  bsMouseDown   = $0008;
  bsMouseUpDown = $0010;
  bsDefault     = $0020;

{ GetAppInstance -----------------------------------------------
    Returns a handle to the current client application.
  -------------------------------------------------------------- }
function GetAppInstance: THandle; near; assembler;
asm
    PUSH    SS
    CALL    GlobalHandle
end;

{ IsWorkshopWindow ---------------------------------------------
    Returns true if the window belongs to Resource Workshop.
    Used to determine if the control is being edited; allowing
    the LoadResRW function to be called.
  -------------------------------------------------------------- }
function IsWorkshopWindow(Wnd: HWnd): Boolean;
var
  Parent: HWnd;
  ClassName: array[0..80] of Char;
begin
  Parent := Wnd;
  repeat
    Wnd := Parent;
    Parent := GetParent(Wnd);
  until Parent = 0;
  GetClassName(Wnd, ClassName, SizeOf(ClassName));
  IsWorkshopWindow := StrComp(ClassName, 'rwswnd') = 0;
end;

{ LoadResRW ----------------------------------------------------
    Load a resource from Resource Workshop. Initialized by
    ListClasses below.
  -------------------------------------------------------------- }
var
  LoadResRW: TLoad;

{ LoadBitmapRW -------------------------------------------------
    Load a bitmap from Resource Workshop.  *MUST* be called from
    inside resource workshop (IsWorkshopWindow must be true).
  -------------------------------------------------------------- }
function LoadBitmapRW(szTitle: PChar): HBitmap;
var
  Res: THandle;
  Bits: PBitMapInfoHeader;
  DC: HDC;
  nColors: Integer;

function GetDInColors(BitCount: Integer): Integer;
begin
  case BitCount of
    1, 3, 4, 8: GetDInColors := 1 shl BitCount;
  else
    GetDInColors := 0;
  end;
end;

begin
  LoadBitmapRW := 0;
  Res := LoadResRW(rt_Bitmap, szTitle);
  if Res <> 0 then
  begin
    Bits := GlobalLock(Res);
    if Bits^.biSize = SizeOf(TBitMapInfoHeader) then
    begin
      nColors := GetDInColors(Bits^.biBitCount);
      DC := GetDC(0);
      if DC <> 0 then
      begin
    LoadBitmapRW := CreateDIBitmap(DC, Bits^, cbm_Init,
      Pointer(LongInt(Bits) + SizeOf(Bits^) +
      nColors * SizeOf(TRGBQuad)), PBitmapInfo(Bits)^,
      dib_RGB_Colors);
    ReleaseDC(0, DC);
      end;
    end;
    GlobalUnlock(Res);
    GlobalFree(Res);
  end;
end;

{ BitButtonWinFn -----------------------------------------------
    Button window procedure.
  -------------------------------------------------------------- }
function BitButtonWinFn(HWindow: HWnd; Message: Word; wParam: Word;
  lParam: Longint): Longint; export;
var
  DC: HDC;
  BitsNumber: Integer;
  Bitmap: TBitmap;
  Rect: TRect;
  Pt: TPoint;
  PS: TPaintStruct;

{ Get ----------------------------------------------------------
    Get a window instance word.
  -------------------------------------------------------------- }
function Get(Ofs: Integer): Word;
begin
  Get := GetWindowWord(HWindow, Ofs);
end;

{ SetWord ------------------------------------------------------
    Set the value of a window instance word.
  -------------------------------------------------------------- }
procedure SetWord(Ofs: Integer; Val: Word);
begin
  SetWindowWord(HWindow, Ofs, Val);
end;

{ State --------------------------------------------------------
    Get the button's state word.
  -------------------------------------------------------------- }
function State: Word;
begin
  State := Get(ofState);
end;

{ DownBits -----------------------------------------------------
    Get the "down" bitmap of the button.
  -------------------------------------------------------------- }
function DownBits: Word;
begin
  DownBits := Get(ofDownBits);
end;

{ UpBits -------------------------------------------------------
    Get the "up" bitmap of the button.
  -------------------------------------------------------------- }
function UpBits: Word;
begin
  UpBits := Get(ofUpBits);
end;

{ FocUpBits ----------------------------------------------------
    Get the "focused up" bitmap of the button.
  -------------------------------------------------------------- }
function FocUpBits: Word;
begin
  FocUpBits := Get(ofFocUpBits);
end;

{ GetState -----------------------------------------------------
    Get the value of a state bit.
  -------------------------------------------------------------- }
function GetState(AState: Word): Boolean;
begin
  GetState := (State and AState) = AState;
end;

{ Paint --------------------------------------------------------
    Paint the button.  Called in responce to a WM_PAINT message
    and whenever the button changes state (called by Repaint).
  -------------------------------------------------------------- }
procedure Paint(DC: HDC);
const
  coGray = $00C0C0C0;
var
  MemDC: HDC;
  Bits, Oldbitmap: HBitmap;
  BorderBrush, OldBrush: HBrush;
  LogBrush: TLogBrush;
  Frame: TRect;
  Height, Width: Integer;
begin
  if (State and (bsMouseDown + bsKeyDown) <> 0) and
      not GetState(bsMouseUpDown) then
    Bits := DownBits
  else
    if GetState(bsFocus) then
      Bits := FocUpBits
    else
      Bits := UpBits;

  { Draw border }
  GetClientRect(HWindow, Frame);
  Height := Frame.bottom - Frame.top;
  Width := Frame.right - Frame.left;

  if GetState(bsDefault) then
    BorderBrush := GetStockObject(Black_Brush)
  else BorderBrush := GetStockObject(White_Brush);
  OldBrush := SelectObject(DC, BorderBrush);
  PatBlt(DC, Frame.left, Frame.top, Width, bdBorderWidth, PatCopy);
  PatBlt(DC, Frame.left, Frame.top, bdBorderWidth, Height, PatCopy);
  PatBlt(DC, Frame.left, Frame.bottom - bdBorderWidth, Width,
    bdBorderWidth, PatCopy);
  PatBlt(DC, Frame.right - bdBorderWidth, Frame.top, bdBorderWidth,
    Height, PatCopy);
  SelectObject(DC, OldBrush);

  { Draw bitmap }
  MemDC := CreateCompatibleDC(DC);
  OldBitmap := SelectObject(MemDC, Bits);
  GetObject(Bits, Sizeof(Bitmap), @Bitmap);
  if GetState(bsDisabled) then
  begin
    { Gray out the button }
    OldBrush := SelectObject(DC, CreateSolidBrush(coGray));
    PatBlt(DC, bdBorderWidth, bdBorderWidth, Bitmap.bmWidth,
      Bitmap.bmHeight, PatCopy);
    DeleteObject(SelectObject(DC, OldBrush));

    { Draw the bitmap through a checked brush }
    LogBrush.lbStyle := bs_Pattern;
    LogBrush.lbHatch := LoadBitmap(HInstance, MakeIntResource(btDisableBits));
    OldBrush := SelectObject(DC, CreateBrushIndirect(LogBrush));
    BitBlt(DC, bdBorderWidth, bdBorderWidth, Bitmap.bmWidth,
      Bitmap.bmHeight, MemDC, 0, 0, $00A803A9 {DPSoa});
    DeleteObject(SelectObject(DC, OldBrush));
    DeleteObject(LogBrush.lbHatch);
  end
  else
    BitBlt(DC, bdBorderWidth, bdBorderWidth, Bitmap.bmWidth,
      Bitmap.bmHeight, MemDC, 0, 0, srcCopy);
  SelectObject(MemDC, OldBitmap);

  DeleteDC(MemDC);
end;

{ Repaint ------------------------------------------------------
    Repaint the button. Called whenever the button changes
    state.
  -------------------------------------------------------------- }
procedure Repaint;
var
  DC: HDC;
begin
  DC := GetDC(HWindow);
  Paint(DC);
  ReleaseDC(HWindow, DC);
end;

{ SetState -----------------------------------------------------
    Sets the value of a state bit.  If the word changes value
    the button is repainted.
  -------------------------------------------------------------- }
procedure SetState(AState: Word; Enable: Boolean);
var
  OldState, NewState: Word;
begin
  OldState := State;
  if Enable then NewState := OldState or AState
  else NewState := OldState and not AState;
  if NewState <> OldState then
  begin
    SetWord(ofState, NewState);
    Repaint;
  end;
end;

{ InMe ---------------------------------------------------------
    Returns true if the given point is in within the border of
    the button.
  -------------------------------------------------------------- }
function InMe(lPoint: Longint): Boolean;
var
  R: TRect;
  Point: TPoint absolute lPoint;
begin
  GetClientRect(HWindow, R);
  InflateRect(R, -bdBorderWidth, -bdBorderWidth);
  InMe := PtInRect(R, Point);
end;

{ ButtonPressed ------------------------------------------------
    Called when the button is pressed by either the keyboard or
    by the mouse.
  -------------------------------------------------------------- }
procedure ButtonPressed;
begin
  SetState(bsMouseDown + bsMouseUpDown + bsKeyDown, False);
  SendMessage(GetParent(HWindow), wm_Command, GetDlgCtrlID(HWindow),
    Longint(HWindow));
end;

{ LoadBits -----------------------------------------------------
    Load the bitmap for the button or the "NO BITMAP" version
    if it does not exist.
  -------------------------------------------------------------- }
procedure LoadBits(Wrd: Word; MapNumber: Word);
var
  MapBits: HBitmap;
begin
  MapBits := LoadBitmap(HInstance, pChar(MapNumber));
  if MapBits = 0 then
    if IsWorkshopWindow(HWindow) then
      MapBits := LoadBitmapRW(pChar(MapNumber))
    else
      MapBits := LoadBitmap(GetAppInstance, pChar(MapNumber));
  if MapBits = 0 then
    MapBits := LoadBitmap(HInstance, pChar(MapNumber - Get(gww_ID)));
  SetWord(Wrd, MapBits);
end;

begin
  BitButtonWinFn := 0;
  case Message of
    wm_Create:
      begin
    { Detect EGA monitor }
    DC := GetDC(0);
    if (GetSystemMetrics(sm_CYScreen) < 480) or
        (GetDeviceCaps(DC, numColors) < 16) then
      BitsNumber := 2000 + Get(gww_ID)
    else
      BitsNumber := 1000 + Get(gww_ID);
    ReleaseDC(0, DC);

    { Load bitmaps from resource }
    LoadBits(ofUpBits, BitsNumber);
    LoadBits(ofDownBits, BitsNumber + 2000);
    LoadBits(ofFocUpBits, BitsNumber + 4000);

    { Adjust size of button to size of bitmap }
    GetObject(DownBits, SizeOf(Bitmap), @Bitmap);
    GetWindowRect(HWindow, Rect);
    Pt.X := Rect.Left;
    Pt.Y := Rect.Top;
    ScreenToClient(PCreateStruct (lParam)^.hwndParent, Pt);
      MoveWindow(HWindow, Pt.X, Pt.Y,
      Bitmap.bmWidth + bdBorderWidth * 2,
      Bitmap.bmHeight + bdBorderWidth * 2, False);

    { Intialize button state }
    with PCreateStruct(lParam)^ do
    begin
      if style and $1F = bs_DefPushButton then
        SetState(bsDefault, True);
      if style and ws_Disabled <> 0 then
        SetState(bsDisabled, True);
    end;
      end;
    wm_NCDestroy:
      begin
    { Destroy all saved bitmaps before the button is destroyed }
    BitButtonWinFn := DefWindowProc(HWindow, Message, wParam, lParam);
    DeleteObject(UpBits);
    DeleteObject(DownBits);
    DeleteObject(FocUpBits);
      end;
    wm_Paint:
      begin
    BeginPaint(HWindow, PS);
    Paint(PS.hDC);
    EndPaint(HWindow, PS);
      end;
    wm_EraseBkGnd:
      begin
    { Squelch the painting of the background to eliminate flicker }
      end;
    wm_Enable:
      SetState(bsDisabled, wParam <> 0);
    wm_SetFocus:
      SetState(bsFocus, True);
    wm_KillFocus:
      SetState(bsFocus or bsKeyDown or bsMouseDown or bsMouseUpDown, False);
    wm_KeyDown:
      if (wParam = $20) and not GetState(bsKeyDown) and
      not GetState(bsMouseDown) then
    SetState(bsKeyDown, True);
    wm_KeyUp:
      if (wParam = $20) and GetState(bsKeyDown) then
        ButtonPressed;
    wm_LButtonDblClk, wm_LButtonDown:
      if InMe(lParam) and not GetState(bsKeyDown) then
      begin
    if GetFocus <> HWindow then SetFocus(HWindow);
    SetState(bsMouseDown, True);
    SetCapture(HWindow);
      end;
    wm_MouseMove:
      if GetState(bsMouseDown) then
    SetState(bsMouseUpDown, not InMe(lParam));
    wm_LButtonUp:
      if GetState(bsMouseDown) then
      begin
    ReleaseCapture;
    if not GetState(bsMouseUpDown) then ButtonPressed
    else SetState(bsMouseDown + bsMouseUpDown, False);
      end;

    { *** Handling the rest of these messages are what, at least for
          the dialog manager, makes a push button a push button.  ***}
    wm_GetDlgCode:
      { Sent by the dialog manager to determine the control kind of
    a child window.  Returning dlgc_DefPushButton or
    dlgc_UndefPushButton causes the dialog manager to treat the
    control like a button, sending the bm_SetStyle message to
    move the default button style to the currenly focused button.

        The dlgc_Button constant is not documented by Microsoft
        (however, it is documented for OS/2 PM, and appears to work
        the same). If this constant is or'd in, the windows dialog
        manager will take care of all accelerator key processing,
        sending bm_SetState and bm_SetStyle messages when an
        acclerator key is pressed. There is a side effect to using
        the message, however, the dialog manager messes with the word
        at offset 0 from the user Window words. }

      if GetState(bsDefault) then
    BitButtonWinFn:= dlgc_DefPushButton or dlgc_Button
      else
    BitButtonWinFn := dlgc_UndefPushButton or dlgc_Button;
    bm_GetState:
      BitButtonWinFn := Integer(GetState(bsKeyDown));
    bm_SetState:
      SetState(bsKeyDown, wParam <> 0);
    bm_SetStyle:
      { Sent by the dialog manager when the button receives or looses
    focus and is not the default button, or when another button
    receives the focus and this button is the default button. }
      SetState(bsDefault, wParam = bs_DefPushButton);
  else
    BitButtonWinFn := DefWindowProc(HWindow, Message, wParam, lParam);
  end;
end;

{ ==============================================================
  Custom contol interface routines.
  ============================================================== }

{ BitBtnInfo ---------------------------------------------------
   Return the information about the capabilities of the
   bit button class.
  -------------------------------------------------------------- }
function BitBtnInfo: THandle; export;
var
  hInfo: THandle;
  Info: PRWCtlInfo;
begin
  hInfo := GlobalAlloc(gmem_Share or gmem_ZeroInit,
    SizeOf(TRWCtlInfo));
  if hInfo <> 0 then
  begin
    Info := GlobalLock(hInfo);
    with Info^ do
    begin
      wVersion := $100;         { Version 1.00 }
      wCtlTypes := 2;           { 2 types }
      StrCopy(szClass, 'BitButton');
      StrCopy(szTitle, 'Button');

      { Normal (Un-default) push button type }
      with ctType[0] do
      begin
    wWidth := 63 or $8000;
    wHeight := 39 or $8000;
    StrCopy(szDescr, 'Push Button');
    dwStyle := bs_PushButton or ws_TabStop;
    hToolBit := LoadBitmap(HInstance, MakeIntResource(btUndefBits));
    hDropCurs := LoadCursor(HInstance, MakeIntResource(crUndefCurs));
      end;

      { Default push button type }
      with ctType[1] do
      begin
    wWidth := 63 or $8000;
    wHeight := 39 or $8000;
    StrCopy(szDescr, 'Default Push Button');
    dwStyle := bs_DefPushButton or ws_TabStop;
    hToolBit := LoadBitmap(HInstance, MakeIntResource(btDefBits));
    hDropCurs := LoadCursor(HInstance, MakeIntResource(crDefCurs));
      end;
    end;
    GlobalUnlock(hInfo);
  end;
  BitBtnInfo := hInfo;
end;

type
  PParamRec = ^TParamRec;
  TParamRec = record
    CtlStyle: THandle;
    IdToStr: TIdToStr;
    StrToId: TStrToId;
  end;

{ BitBtnStyleDlg -----------------------------------------------
    Style dialog's dialog hook.  Used by the dialog and called
    when the control is double-clicked inside the dialog
    editor.
  -------------------------------------------------------------- }
function BitBtnStyleDlg(HWindow: HWnd; Message: Word; wParam: Word;
  lParam: Longint): Longint; export;
const
  Prop = 'Prop';
var
  hRec: THandle;
  Rec: PParamRec;
  Style: PCtlStyle;
  S: array[0..256] of Char;
  Radio: Integer;
begin
  case Message of
    wm_InitDialog:
      begin
    hRec := LoWord(lParam);
    Rec := GlobalLock(hRec);
    Style := GlobalLock(Rec^.CtlStyle);
    SetProp(HWindow, Prop, hRec);
    with Rec^, Style^ do
    begin
      { Set caption }
      SetDlgItemText(HWindow, idCaption, szTitle);

      { Set control id }
      IdToStr(wId, S, SizeOf(S));
      SetDlgItemText(HWindow, idControlId, S);

      { Set type radio buttons }
      if dwStyle and $F = bs_DefPushButton then
        Radio := idDefaultButton
      else
            Radio := idPushButton;
      CheckRadioButton(HWindow, idDefaultButton, idPushButton,
        Radio);

      { Initialize Tab Stop check box }
      CheckDlgButton(HWindow, idTabStop,
        Integer(dwStyle and ws_TabStop <> 0));

      { Initialize Disabled check box }
      CheckDlgButton(HWindow, idDisabled,
        Integer(dwStyle and ws_Disabled <> 0));

      { Initialize Group check box }
      CheckDlgButton(HWindow, idGroup,
        Integer(dwStyle and ws_Group <> 0));
    end;
    GlobalUnlock(Rec^.CtlStyle);
    GlobalUnlock(hRec);
      end;
    wm_Command:
      case wParam of
    idCancel:
      EndDialog(HWindow, 0);
    idOk:
      begin
        hRec := GetProp(HWindow, Prop);
        Rec := GlobalLock(hRec);
        Style := GlobalLock(Rec^.CtlStyle);
        with Rec^, Style^ do
        begin
          { Get caption }
          GetDlgItemText(HWindow, idCaption, szTitle, SizeOf(szTitle));

          { Get control id }
          GetDlgItemText(HWindow, idControlId, S, SizeOf(S));
          wId := StrToId(S);

          { Get button type }
          if IsDlgButtonChecked(HWindow, idDefaultButton) <> 0 then
        dwStyle := bs_DefPushButton
          else
                dwStyle := bs_PushButton;

          { Get tab stop }
          if IsDlgButtonChecked(HWindow, idTabStop) <> 0 then
        dwStyle := dwStyle or ws_TabStop;

          { Get disabled }
          if IsDlgButtonChecked(HWindow, idDisabled) <> 0 then
        dwStyle := dwStyle or ws_Disabled;

          { Get group }
          if IsDlgButtonChecked(HWindow, idGroup) <> 0 then
        dwStyle := dwStyle or ws_Group;
        end;
        GlobalUnlock(Rec^.CtlStyle);
        GlobalUnlock(hRec);
        EndDialog(HWindow, 1);
      end;
      else
    BitBtnStyleDlg := 0;
      end;
    wm_Destroy:
      RemoveProp(HWindow, Prop);
  else
    BitBtnStyleDlg := 0;
  end;
end;

{ BitBtnStyle --------------------------------------------------
    The function will bring up a dialog box to modify the style
    of the button.  Called when the button is double-clicked in
    the dialog editor.
  -------------------------------------------------------------- }
function BitBtnStyle(hWindow: HWnd; CtlStyle: THandle;
  StrToId: TStrToId; IdToStr: TIdToStr): Bool; export;
var
  hRec: THandle;
  Rec: PParamRec;
  hFocus: HWnd;
begin
  BitBtnStyle := False;
  hRec := GlobalAlloc(gmem_Share, SizeOf(TParamRec));
  if hRec <> 0 then
  begin
    Rec := GlobalLock(hRec);
    Rec^.IdToStr := IdToStr;
    Rec^.StrToId := StrToId;
    Rec^.CtlStyle := CtlStyle;
    GlobalUnlock(hRec);

    hFocus := GetFocus;
    BitBtnStyle := Bool(DialogBoxParam(HInstance,
      MakeIntResource(idButtonStyle), HWindow, @BitBtnStyleDlg,
      hRec));
    if hFocus <> 0 then SetFocus(hFocus);
    GlobalFree(hRec);
  end;
end;

{ BitBtnFlags --------------------------------------------------
    Called to decompose the style double word into the .RC
    script expression that it represents.  This only needs to
    decompose the style bits added to the style double word,
    it need not decompose the, for example, the ws_XXX bits.
    The expression returned must be a valid .RC expression
    (i.e. C syntax, case sensitive).
  -------------------------------------------------------------- }
function BitBtnFlags(Style: LongInt; Buff: PChar;
  BuffLength: Word): Word; export;
begin
  if Style and $F = bs_DefPushButton then
    StrLCopy(Buff, 'BS_DEFPUSHBUTTON', BuffLength)
  else StrLCopy(Buff, 'BS_PUSHBUTTON', BuffLength);
  BitBtnFlags := StrLen(Buff);
end;

{ ListClasses --------------------------------------------------
    Called by Resource Workshop retrieve the information
    necessary to edit the custom controls contain in this DLL.
    This is an alternative to the Microsoft xxxStyle convention.
  -------------------------------------------------------------- }
function ListClasses(szAppName: PChar; wVersion: Word;
  fnLoad: TLoad; fnEdit: TEdit): THandle; export;
var
  hClasses: THandle;
  Classes: PCtlClassList;
begin
  LoadResRW := fnLoad;
  hClasses := GlobalAlloc(gmem_Share or gmem_ZeroInit,
    SizeOf(Integer) + SizeOf(TRWCtlClass));
  if hClasses <> 0 then
  begin
    Classes := GlobalLock(hClasses);
    with Classes^ do
    begin
      nClasses := 1;
      with Classes[0] do
      begin
    fnInfo  := BitBtnInfo;
    fnStyle := BitBtnStyle;
    fnFlags := BitBtnFlags;
      end;
    end;
    GlobalUnlock(hClasses);
  end;
  ListClasses := hClasses;
end;

exports
  ListClasses,
  BitButtonWinFn;

var
  Class: TWndClass;

begin
  with Class do
  begin
    lpszClassName := 'BitButton';
    hCursor       := LoadCursor(0, idc_Arrow);
    lpszMenuName  := nil;
    style         := cs_HRedraw or cs_VRedraw or cs_DblClks or cs_GlobalClass;
    lpfnWndProc   := TFarProc(@BitButtonWinFn);
    hInstance     := System.hInstance;
    hIcon         := 0;
    cbWndExtra    := ofSize;
    cbClsExtra    := 0;
    hbrBackground := 0;
  end;
  RegisterClass(Class);
end.